Internet Info 1994 March/Internet Info CD-ROM (Walnut Creek) (March 1994).iso/networking/terms/kermit/c/ucterak.pas

Pascal/Delphi Source File | 1988-08-16 | 88.0 KB | 2,767 lines

>>>> UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U
>>>>
>>>> All files are concatenated together into this single file, separated by
>>>> lines beginning like this one does, followed by the name of the file.
>>>>
>>>> HELP.TEXT
segment procedure help;

procedure keypress;

const clearscreen = 12;

var ch: char;

  begin
    writeln('---------------Press any key to continue---------------');
    repeat
    until readch(kq,ch);
    writeln(chr(clearscreen))
  end; (* keypress *)

procedure help1;

var ch: char;

begin
if (noun = nullsym) then
begin
writeln('KERMIT is a family of  programs that do reliable file transfer');
write('between computers over TTY lines.  KERMIT can also be ');
writeln('used to make the ');
writeln('microcomputer behave as a terminal for a mainframe.  These are the ');
writeln('commands for theUCSD p-system version, KERMIT-UCSD:');
writeln
end; (* if *)
if (noun = nullsym) or (noun = consym) then
begin
writeln('  CONNECT     To make a "virutual terminal" connection to a remote');
writeln('              system.');
writeln;
write('              To break the connection and "escape" back to the micro,');
writeln;
writeln('              type the escape sequence (CTRL-] C, that is Control ');
writeln('              rightbracket followed immediately by the letter C.)');
writeln;
end; (* if *)
if (noun = nullsym) or (noun = exitsym) then
begin
writeln('  EXIT        To return back to main command level of the p-system.');
writeln;
end; (* if *)
if (noun = nullsym) or (noun = helpsym) then
begin
writeln('  HELP        To get a list of KERMIT commands.');
writeln;
end; (* if *)
if (noun = nullsym) or (noun = quitsym) then
begin
writeln('  QUIT        Same as EXIT.');
writeln;
end; (* if *)
if (noun = nullsym) or (noun = recsym) then
begin
writeln('  RECEIVE     To accept a file from the remote system.');
writeln;
end; (* if *)
end; (* help1 *)

procedure help2;

var ch: char;

begin
if (noun = nullsym) or (noun = sendsym) then
begin
writeln('  SEND        To send a file or group of files to the remote system.');
writeln;
end; (* if *)
if (noun = nullsym) then
    keypress;
if (noun = nullsym) or (noun = setsym) then
begin
writeln('  SET         To establish system-dependent parameters.  The ');
writeln('              SET options are as follows: ');
writeln;
if (adj = nullsym) or (adj = debugsym) then
begin
writeln('              DEBUG            To set debug mode ON or OFF ');
writeln('                               (default is OFF).');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = escsym) then
begin
writeln('              ESCAPE           To change the escape sequence that ');
writeln('                               lets you return to the PC Kermit from');
write('                               the remote host.');
writeln('  The default is CTRL-] c.');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = filewarnsym) then
begin
writeln('              FILE-WARNING     ON/OFF, default is OFF.  If ON, ');
writeln('                               Kermit will warn you and rename an ');
writeln('                               incoming file so as not to write over');
writeln('                               a file that currently exists with the');
writeln('                               same name');
writeln;
end; (* if *)
if (adj = nullsym) then
    keypress;
end; (* if *)
end; (* help2 *)

procedure help3;

begin
if (noun = nullsym) or (noun = setsym) then
begin
if (adj = nullsym) or (adj = ibmsym) then
begin
writeln('              IBM              ON/OFF, default is OFF.  This flag ');
write('                               should be ON only when ');
writeln('transfering files');
writeln('                               between the micro and an IBM VM/CMS');
writeln('                               system.  It also causes the parity to');
write('                               be set appropriately ');
writeln('(mark) and activates');
writeln('                               local echoing');
writeln;
end; (* if *)
if (adj = nullsym) or (adj = localsym) then
begin
write('              LOCAL-ECHO       ON/OFF, default is OFF.  This sets the');
writeln;
writeln('                               duplex.  It should be ON when using ');
writeln('                               the IBM and OFF for the DEC-20.');
writeln;
end; (* if *)
end; (* if *)
end; (* help3 *)

procedure help4;

begin
if (noun = setsym) or (noun = nullsym) then
begin
if (adj = nullsym) or (adj = paritysym) then
begin
writeln('              PARITY           EVEN, ODD, MARK, SPACE, or NONE.');
writeln('                               NONE is the default but if the IBM ');
writeln('                               flag is set, parity is set to MARK.  ');
writeln('                               This flag selects the parity for ');
write('                               outgoing and incoming characters during');
writeln;
write('                               CONNECT and file transfer to match the');
writeln;
writeln('                               requirements of the host.');
writeln;
end; (* if *)
end; (* if *)
if (noun = nullsym) or (noun = showsym) then
begin
writeln('  SHOW        To see the values of parameters that can be modified');
writeln('              via the SET command.  Options are the same as for SET,');
writeln('              except that a SHOW ALL command has been added.');
end; (* if *)
end; (* help4 *)

begin
help1;
help2;
help3;
help4
end; (* help *)


>>>> KBDHANDLR.TEXT
;                        ----------------------------
;                        KBDHNDLR TTY Receive Handler
;                        ----------------------------
;
;    Two routines are provided that maintain an interrupt-driven
;    TTY-receive queue.  Appropriate PASCAL declarations are:
;
;        CONST KQSIZE = maximum number of queued characters
;
;        TYPE QUEUE = RECORD    (* These are order-dependent !!! *)
;                       QSIZE: INTEGER;
;                       INP: INTEGER;
;                       OUTP: INTEGER;
;                       MAXCHAR: INTEGER;
;                       DATA: PACKED ARRAY [0..RCVQSIZE] OF CHAR;
;                     END;
;        VAR KQ: QUEUE;     (* must be declared in outermost block *)
;
;        PROCEDURE KBDINIT (VAR Q: QUEUE; SIZE:INTEGER); EXTERNAL;
;        PROCEDURE KBDFINIT; EXTERNAL;
;
;        KBDINIT (KQ,KQSIZE);    (* initialize the queue handler *)
;
;        WHILE TRUE DO
;          WITH KQ DO
;           IF INP <> OUTP THEN    (* characters available *)
;             BEGIN
;               CH := DATA[OUTP];
;               OUTP := OUTP+1; IF OUTP > QSIZE THEN OUTP := 0;
;                ...
;             END;
;
;        KBDFINIT;       (* terminate the queue handler *)
;
;    The RECORD declaration for the queue must appear exactly as it
;    does above except that you can of course use any names you like.
;    Do NOT attempt to lump the first four integer variables together
;    into a single group of the form list:INTEGER.  In that case,
;    the compiler allocates them in reverse order, so that your code
;    and the interrupt handler will not agree about which words have
;    what meaning.
;
;    The queue handler runs continuously as an interrupt-driven task
;    at high priority.  As characters come in, it advances the queue
;    INP pointer and keeps track of the maximum number of characters in
;    the queue in the MAXCHAR variable.  Queue overflow is indicated
;    by MAXCHAR > QSIZE.  You must terminate by calling KBDFINIT, or
;    the TTY receive interrupts will be left enabled and you will end
;    up crashing the system by executing garbage code when the next
;    character is received.  (KBDFINIT also repairs the interrupt
;    vectors for breakpoints and the clock, so failing to call it will
;    quite likely crash the system even in the absence of incoming
;    TTY characters.)
;
;    The manipulation of the clock and BPT interrupt vectors is borrowed
;    from UCSD's old communications program.  The purpose is to allow
;    the clock handler to be interrupted by incoming TTY characters.
;
KDB       .EQU   177562          ; Receive Data Buffer absolute address
KSR       .EQU   177560          ; Receive Status Register absolute address
KINTV     .EQU       60          ; Receiver Interrupt Vector address
CLKINTV   .EQU      100          ; Clock interrupt vector address
BPTINTV   .EQU       14          ; BPT interrupt vector address
QXCINTV   .EQU      250          ; QX controller interrupt vector
;
          .PROC  KBDINIT,2         ; (VAR Q:QUEUE, SIZE:INTEGER)
;
          .DEF   KBDLOC          ; holds vector address
          .DEF   KBDPR           ; holds old priority
Q         .EQU   4               ; stack offset for Q address
SIZE      .EQU   2               ; stack offset for QSIZE value
;
          MOV    Q(SP),R0        ; obtain the Q record address
          MOV    R0,KQADRS       ; remember Q address
          MOV    SIZE(SP),(R0)+  ; store size in QSIZE word
          MOV    #0,(R0)+        ; clear INP, OUTP, and MAXCHAR
          MOV    #0,(R0)+
          MOV    #0,(R0)
;
;
          MOV    @#KINTV,KBDLOC      ; save old interrupt vector
          MOV    @#KINTV+2,KBDPR     ; and old priority

          MOV    #KHNDLR,@#KINTV     ; store interrupt handler address
          MOV    #200,@#KINTV+2      ; set interrupt priority 4 for TTY input
          ;MOV    #100,@#KSR          ; enable interrupts for TTY input
;
          MOV    (SP)+,R0        ; pop return address from stack
          ADD    #4,SP           ; discard 2 parameters (4 bytes)
          JMP    @R0             ; and return to PASCAL interpreter
;
KQADRS    .WORD   0              ; holds Q address for handler
KBDLOC    .WORD   0              ; holds old interrupt vector
KBDPR     .WORD   0              ; holds old interrupt priority
;
QSIZE     .EQU    0              ; offset from Q
INP       .EQU    2              ; likewise
OUTP      .EQU    4
MAXCHAR   .EQU    6
DATA      .EQU   10
;
KHNDLR:   MOV    R0,-(SP)        ; free registers R0, R1, R2 for use
          MOV    R1,-(SP)
          MOV    R2,-(SP)
          MOV    KQADRS,R2       ; fetch Q address saved by KBDINIT
          MOV    INP(R2),R0      ; fetch INP value
          MOV    R0,R1           ; make a working copy
          ADD    R2,R1           ; R1 = address (Q) + value (INP)
          MOVB   @#KDB,DATA(R1)  ; DATA[INP] := input character
          BICB   #200,DATA(R1)   ; clear bit 8 (parity)
          BEQ    EXIT            ; ignore nulls (do not bump INP)
          INC    R0              ; INP := INP+1
          CMP    QSIZE(R2),R0
          BPL    NOWRAP          ; if QSIZE >= INP then no wraparound
          CLR    R0              ; else INP := 0
NOWRAP    MOV    R0,INP(R2)      ; restore INP
;
          SUB    OUTP(R2),R0
          BMI    INOUT
          BEQ    INOUT
          BR     OUTIN           ; if INP > OUTP, # char = INP - OUTP
INOUT     ADD    QSIZE(R2),R0    ; otherwise, # char = QSIZE+1 + INP - OUTP
          ADD    #1,R0
OUTIN     CMP    MAXCHAR(R2),R0
          BPL    EXIT            ; if MAXCHAR >= # char, exit
          MOV    R0,MAXCHAR(R2)  ; otherwise, store new MAXCHAR
;
EXIT      MOV    (SP)+,R2        ; restore registers for caller
          MOV    (SP)+,R1
          MOV    (SP)+,R0
          RTT                    ; return from interrupt
;
CLKHNDLR: COM    CLKFLG          ; do not reexecute BPT if BPT handler
          BEQ    CLKEXIT         ;   takes so long that clock ticks again
          BPT                    ; let breakpoint transfer to old clock
CLKEXIT   COM    CLKFLG          ; reset flag
          RTI                    ; and exit
;
CLKFLG    .WORD  0               ; flags reentry before BPT exit
;
          .PROC  KBDFINIT
          .REF   KBDLOC          ; old interrupt vector saved by KBDINIT
          .REF   KBDPR           ; old kbd priority saved by KBDINIT
;
           MOV    @#KBDPR,@#KINTV+2    ; restore interrupt priority
           MOV    @#KBDLOC,@#KINTV     ; and interrupt vector
           RTS    PC                   ; and return
;
           .END


>>>> KERMIT.TEXT
program kermit;

(* $R-*) (* turn range checking off *)
(*$S+*) (* turn swapping on *)
(* $L+*)
(*$U PARSELIB.CODE*)
USES PARSER;

const blksize = 512;
      oport = 8;          (* output port # *)
      clearscreen = 12;   (* charcter which erases screen *)
      bell = 7;           (* ASCII bell *)
      maxpack = 93;       (* maximum packet size minus 1 *)
      soh = 1;            (* start of header *)
      sp = 32;            (* ASCII space *)
      cr = 13;            (* ASCII CR *)
      lf = 10;            (* ASCII line feed *)
      dle = 16;           (* ASCII DLE (space compression prefix for psystem) *)
      del = 127;          (* delete *)
      my_esc = 29;        (* default esc char for connect (^]) *)
      maxtry = 5;         (* number of times to retry sending packet *)
      my_quote = '#';     (* quote character I'll use *)
      my_pad = 0;         (* number of padding chars I need *)
      my_pchar = 0;       (* padding character I need *)
      my_eol = 13;        (* end of line character i need *)
      my_time = 5;        (* seconds after which I should be timed out *)
      maxtim = 20;        (* maximum timeout interval *)
      mintim = 2;         (* minimum time out interval *)
      at_eof = -1;        (* value to return if at eof *)
      rqsize = 5000;      (* input queue size *)
      qsize1 = 5001;      (* qsize + 1 *)
      eoln_sym = 13;      (* pascal eoln sym *)
      back_space = 8;     (* pascal backspace sym *)

(* screen control information *)
  (* console line on which to put specified info *)
      title_line = 1;
      statusline = 2;
      packet_line = 3;
      retry_line = 4;
      file_line = 5;
      error_line = 6;
      debug_line = 7;
      prompt_line = 8;
  (* position on line to put info *)
      statuspos = 70;
      packet_pos = 19;
      retry_pos = 17;
      file_pos = 11;

type queue = record (* input queue *)
                 qsize: integer;
                 inp: integer;
                 outp: integer;
                 maxchar: integer;
                 data: packed array[0..rqsize] of char;
               end; (* queue *)
     packettype = packed array[0..maxpack] of char;
     parity_type = (evenpar, oddpar, markpar, spacepar, nopar);

     char_int_rec = record (* allows character to be treated as integer... *)
                           (* is system dependent *)
                      case boolean of
                          true: (i: integer);
                          false: (ch: char)
                    end; (* record *)

     int_bool_rec = record (* allows integer to be treated as boolean... *)
                           (* used for numeric AND,OR,XOR...system dependent *)
                      case boolean of
                          true: (i: integer);
                          false: (b: boolean)
                    end; (* record *)

var kq, rq: queue;
    state: char; (* current state *)
    f: file of char; (* file to be received *)
    oldf: file; (* file to be sent *)
    s: string;
    eol, quote, esc_char: char;
    fwarn, ibm, half_duplex, debug: boolean;
    i, size, rpsiz, spsiz, pad, n, num_try, oldtry, timint: integer;
    recpkt, packet: packettype;
    padchar, ch: char;
    debf: text; (* file for debug output *)
    parity: parity_type;
    xon: char;
    filebuf: packed array[1..1024] of char;
    bufpos, bufend: integer;
    parity_array: packed array[char] of char;
    ctlset: set of char;
    rec_ok, send_ok: boolean;

function read_ch(var q: queue; var ch: char): boolean;
forward;

procedure clear_buf(var q: queue);
forward;

function aand(x,y: integer): integer;
forward;

function aor(x,y: integer): integer;
forward;

function xor(x,y: integer): integer;
forward;

procedure error(p: packettype; len: integer);
forward;

procedure io_error(i: integer);
forward;

procedure debugwrite(s: string);
forward;

procedure debugint(s: string; i: integer);
forward;

procedure writescreen(s: string);
forward;

procedure refresh_screen(numtry, num: integer);
forward;

function min(x,y: integer): integer;
forward;

function tochar(ch: char): char;
forward;

function unchar(ch: char): char;
forward;

function ctl(ch: char): char;
forward;

function getfil(filename: string): boolean;
forward;

procedure bufemp(buffer: packettype; var f: text; len: integer);
forward;

function bufill(var buffer: packettype): integer;
forward;

procedure spar(var packet: packettype);
forward;

procedure rpar(var packet: packettype);
forward;

procedure spack(ptype: char; num:integer; len: integer; data: packettype);
forward;

function getch(var r: char_int_rec; var q: queue): boolean;
forward;

function getsoh(var q: queue): boolean;
forward;

function rpack(var len, num: integer; var data: packettype): char;
forward;

procedure read_str(var q: queue; var s: string);
forward;

procedure show_parms;
forward;

(*$I HELP.TEXT*)
(*$I SENDSW.TEXT*)
(*$I RECSW.TEXT*)

procedure rcvinit(var q: queue; size: integer);
  external;

procedure rcvfinit;
  external;

procedure kbdinit(var q: queue; size: integer);
  external;

procedure kbdfinit;
  external;

procedure sendbrk;
  external;

procedure read_str(*var q: queue; var s: string*);

(* acts like readln(s) but takes input from input queue *)

var i: integer;

  begin
    i := 0;
    s := copy('',0,0);
    repeat
      repeat                              (* get a character *)
      until read_ch(kq,ch);
      if (ord(ch) = backspace) then       (* if it's a backspace then *)
        begin
          if (i > 0) then                   (* if not at beginning of line *)
            begin
              write(ch);                      (* go back a space on screen *)
              write(' ');                     (* erase char on screen *)
              write(ch);                      (* go back a space again *)
              i := i - 1;                     (* adjust string counter *)
              s := copy(s,1,i)                (* adjust string *)
            end (* if *)
        end (* if *)
      else if (ord(ch) <> eoln_sym) then  (* otherwise if not at eoln  then *)
        begin
          write(ch);                        (* echo char on screen *)
          i := i + 1;                       (* inc string counter *)
          s := concat(s,' ');
          s[i] := ch;                       (* put char in string *)
        end; (* if *)
    until (ord(ch) = eoln_sym);           (* if not eoln, get another char *)
    s := copy(s,1,i);                     (* correct string length *)
    writeln                               (* write a line on the screen *)
  end; (* read_str *)

function aand(*x,y: integer): integer*);

(* arithmetic and--takes 2 integers and ands them, yeilding an integer *)

var xrec, yrec, temp: int_bool_rec;

  begin
    xrec.i := x;                  (* put the two numbers in variant record *)
    yrec.i := y;
    temp.b := xrec.b and yrec.b;  (* use as booleans to 'and' them *)
    aand := temp.i                (* return integer result *)
  end; (* aand *)

function aor(*x,y: integer): integer*);

(* arithmetic or *)

var xrec, yrec, temp: int_bool_rec;

  begin
    xrec.i := x;                  (* put two numbers in variant record *)
    yrec.i := y;
    temp.b := xrec.b or yrec.b;   (* use as booleans to 'or' them *)
    aor := temp.i                 (* return integer result *)
  end; (* aor *)

function xor(*x,y: integer): integer*);

(* exclisive or *)

var xrec, yrec, temp: int_bool_rec;

  begin
    xrec.i := x;                  (* put two numbers in variant record *)
    yrec.i := y;
                                  (* use as booleans to 'xor' them *)
    temp.b := (xrec.b or yrec.b) and (not(xrec.b and yrec.b));
    xor := temp.i                 (* return integer result *)
  end; (* xor *)

procedure error(*p: packettype; len: integer*);

(* writes error message sent by remote host *)

var i: integer;

  begin
    gotoxy(0,errorline);
    for i := 0 to len-1 do
        write(p[i]);
    gotoxy(0,promptline);
  end; (* error *)

procedure io_error(*i: integer*);

  begin
    gotoxy(0,errorline);
    write(chr(27),'K');         (* erase to end of line *)
    case i of
        0: writeln('No error');
        1: writeln('Bad Block, Parity error (CRC)');
        2: writeln('Bad Unit Number');
        3: writeln('Bad Mode, Illegal operation');
        4: writeln('Undefined hardware error');
        5: writeln('Lost unit, Unit is no longer on-line');
        6: writeln('Lost file, File is no longer in directory');
        7: writeln('Bad Title, Illegal file name');
        8: writeln('No room, insufficient space');
        9: writeln('No unit, No such volume on line');
        10: writeln('No file, No such file on volume');
        11: writeln('Duplicate file');
        12: writeln('Not closed, attempt to open an open file');
        13: writeln('Not open, attempt to close a closed file');
        14: writeln('Bad format, error in reading real or integer');
        15: writeln('Ring buffer overflow')
      end; (* case *)
    gotoxy(0,promptline)
  end; (* io_error *)

procedure debugwrite(*s: string*);

(* writes a debugging message *)
var i: integer;

  begin
    if debug then
      begin
        gotoxy(0,debugline);
        write(chr(27),'K');         (* erase to end of line *)
        write(s);
        for i := 1 to 2000 do ;                (* write debugging message *)
      end (* if debug *)
  end; (* debugwrite *)

procedure debugint(*s: string; i: integer*);

(* write a debugging message and an integer *)

  begin
    if debug then
      begin
        debugwrite(s);
        write(i)
      end (* if debug *)
  end; (* debugint *)

procedure writescreen(*s: string*);

(* sets up the screen for receiving or sending files *)

  begin
    write(chr(clearscreen));
    gotoxy(0,titleline);
    write('                        Kermit UCSD p-system');
    gotoxy(statuspos,statusline);
    write(s);
    gotoxy(0,packetline);
    write('Number of Packets: ');
    gotoxy(0,retryline);
    write('Number of Tries: ');
    gotoxy(0,fileline);
    write('File Name: ');
  end; (* writescreen *)

procedure refresh_screen(*numtry, num: integer*);

(* keeps track of packet count on screen *)

  begin
    gotoxy(retrypos,retryline);
    write(numtry: 5);
    gotoxy(packetpos,packetline);
    write(num: 5)
  end; (* refresh_screen *)

function min(*x,y: integer): integer*);

(* returns smaller of two integers *)

  begin
    if x < y then
        min := x
    else
        min := y
  end; (* min *)

function tochar(*ch: char): char*);

(* tochar converts a control character to a printable one by adding space *)

  begin
    tochar := chr(ord(ch) + ord(' '))
  end; (* tochar *)

function unchar(*ch: char): char*);

(* unchar undoes tochar *)

  begin
    unchar := chr(ord(ch) - ord(' '))
  end; (* unchar *)

function ctl(*ch: char): char*);

(* ctl toggles control bit: ^A becomes A, A becomes ^A *)

  begin
    ctl := chr(xor(ord(ch),64))
  end; (* ctl *)

procedure echo(ch: char);

(* echos a character on the screen *)

  begin
    ch := chr(aand(ord(ch),127)); (* mask off parity bit *)
    if ch <> chr(lf) then
      begin
        unitwrite(1,ch,1)
      end (* if *)
  end; (* echo *)

procedure clear_buf(*var q: queue*);

(* empties the buffer input buffer *)

  begin
    q.outp := q.inp
  end; (* clear_buf *)

function getfil(*filename: string): boolean*);

(* opens a file for writing *)

  begin
    (*$I-*) (* turn i/o checking off *)
    rewrite(f,filename);
    (*$I-*) (* turn i/o checking on *)
    getfil := (ioresult = 0)
  end; (* getfil *)

procedure bufemp(*buffer: packettype; var f: text; len: integer*);

(* empties a packet into a file *)

var i,ls: integer;
    r: char_int_rec;
    s: string;

  begin
    s := copy('',0,0);
    ls := 0;
    i := 0;
    while i < len do
      begin
        r.ch := buffer[i];          (* get a character *)
        if (r.ch = myquote) then    (* if character is control quote *)
          begin
            i := i + 1;               (* skip over quote and *)
            r.ch := buffer[i];        (* get quoted character *)
            if (aand(r.i,127) <> ord(myquote)) then
                r.ch := ctl(r.ch);    (* controllify it *)
          end; (* if *)
        if (r.i = cr) then          (* else if a carriage return then *)
          begin
            i := i + 3;               (* skip over that and line feed *)
            (*$I-*)                   (* turn i/o checking off *)
            writeln(f,s);             (* and write out line to file *)
            s := copy('',0,0);        (* empty the string var *)
            ls := 0;
            if (io_result <> 0) then  (* if io_error *)
              begin
                io_error(ioresult);     (* tell them and *)
                state := 'a';           (* abort *)
              end (* if *)
          end
      (*$I+*)                      (* turn i/o checking back on *)
      else                        (* else, is a regular char, so *)
          begin
            r.i := aand(r.i,127);     (* mask off parity bit *)
            s := concat(s,' ');       (* and add character to out string *)
            ls := ls + 1;
            s[ls] := r.ch;
            i := i + 1                (* increase buffer pointer *)
          end; (* else *)
      end; (* while *)              (* and get another char *)
      (*$I-*)                     (* turn i/o checking off *)
      write(f,s);                 (* and write out line to file *)
      if (io_result <> 0) then    (* if io_error *)
        begin
          io_error(ioresult);       (* tell them and *)
          state := 'a';             (* abort *)
        end (* if *)
      (*$I+*)                      (* turn i/o checking back on *)
  end; (* bufemp *)

function bufill(*var buffer: packettype): integer*);

(* fill a packet with data from a file...manages a 2 block buffer *)

var i, j, k, t7, count: integer;
    r: char_int_rec;

  begin
    i := 0;
    (* while file has some data & packet has some room we'll keep going *)
    while ((bufpos <= bufend) or (not eof(oldf))) and (i < spsiz-9) do
      begin
        (* if we need more data from disk then *)
        if (bufpos > bufend) and (not eof(oldf)) then
          begin
            (* read a couple of blocks *)
            bufend := blockread(oldf,filebuf[1],2) * blksize;
            (* and adjust buffer pointer *)
            bufpos := 1
          end; (* if *)
        if (bufpos <= bufend) then     (* if we're within buffer bounds *)
          begin
            r.ch := filebuf[bufpos];      (* get a character *)
            bufpos := bufpos + 1;         (* increase buffer pointer *)
            if (r.i = dle) then           (* if it's space compression char, *)
              begin
                count := ord(unchar(filebuf[bufpos])); (* get # of spaces *)
                bufpos := bufpos + 1;       (* read past # *)
                r.ch := ' ';                (* and make current char a space *)
              end (* else if *)
            else                           (* otherwise, it's just a char *)
                count := 1;                (* so only 1 copy of it *)
            if (r.ch in ctlset) then     (* if a control char *)
              begin
                if (r.i = cr) then         (* if a carriage return *)
                  begin
                    buffer[i] := quote;      (* put (quoted) CR in buffer *)
                    i := i + 1;
                    buffer[i] := ctl(chr(cr));
                    i := i + 1;
                    r.i := lf;                (* and we'll stick a LF after *)
                  end; (* if *)
                if r.i <> 0 then           (* if not a NUL then *)
                  begin
                    buffer[i] := quote;      (* put the quote in buffer *)
                    i := i + 1;
                    if r.ch <> quote then
                        r.ch := ctl(r.ch);   (* and un-controllify char *)
                  end (* if *)
              end; (* if *)
          end; (* if *)
        j := 1;
        while (j <= count) and (i <= spsiz - 5) do
          begin                           (* put all the chars in buffer *)
            if (r.i <> 0) then            (* so long as not a NUL *)
              begin
                buffer[i] := r.ch;
                i := i + 1;
              end (* if *)
            else                          (* is a NUL so *)
                if (bufpos > blksize) then  (* skip to end of block *)
                    bufpos := bufend + 1    (* since rest will be NULs *)
                else
                    bufpos := blksize + 1;
            j := j + 1
          end; (* while *)
      end; (* while *)
    if (i = 0) then                         (* if we're at end of file, *)
        bufill := (at_eof)                    (* indicate it *)
    else                                    (* else *)
      begin
        if (j <= count) then                  (* if didn't all fit in packet *)
          begin
            bufpos := bufpos - 2;               (* put buf pointer at DLE *)
                                                (* and update compress count *)
            filebuf[bufpos + 1] := tochar(chr(count-j+1));
          end; (* if *)
        bufill := i                           (* return # of chars in packet *)
      end; (* else *)
  end; (* bufill *)

procedure spar(*var packet: packettype*);

(* fills data array with my send-init parameters *)

  begin
    packet[0] := tochar(chr(maxpack));   (* biggest packet i can receive *)
    packet[1] := tochar(chr(mytime));    (* when i want to be timed out *)
    packet[2] := tochar(chr(mypad));     (* how much padding i need *)
    packet[3] := ctl(chr(mypchar));      (* padding char i want *)
    packet[4] := tochar(chr(myeol));     (* end of line character i want *)
    packet[5] := myquote;                (* control-quote char i want *)
    packet[6] := 'N';                    (* I won't do 8-bit quoting *)
  end; (* spar *)

procedure rpar(*var packet: packettype*);

(* gets their init params *)

  begin
    spsiz := ord(unchar(packet[0]));     (* max send packet size *)
    timint := ord(unchar(packet[1]));    (* when i should time out *)
    pad := ord(unchar(packet[2]));       (* number of pads to send *)
    padchar := ctl(packet[3]);           (* padding char to send *)
    eol := unchar(packet[4]);            (* eol char i must send *)
    quote := packet[5];                  (* incoming data quote char *)
  end; (* rpar *)

procedure packetwrite(p: packettype; len: integer);

(* writes out all of a packet for debugging purposes *)

var i: integer;

  begin
    gotoxy(0,debugline);
    for i := 0 to len+3 do
      begin
        if i = 80 then
          begin
            gotoxy(0,debugline+1);
            write(chr(27),'K');
          end; (* if *)
        write(p[i])
      end; (* for *)
    for i := 1 to 2000 do ;
  end; (* packetwrite *)

procedure spack(*ptype: char; num: integer; len: integer; data: packettype*);

(* send a packet *)

const maxtry = 10000;

var bufp, i, count: integer;
    chksum: char;
    buffer: packettype;
    ch: char;

  begin
    if ibm and (state <> 's') then           (* if ibm and not SINIT then *)
      begin
        count := 0;
        repeat                                 (* wait for an xon *)
            repeat
                count := count + 1
            until (readch(rq,ch)) or (count > maxtry );
        until (ch = xon) or (count > maxtry);
        if count > maxtry then                 (* if wait too long then *)
          begin
            exit(spack)                          (* get out *)
          end; (* if *)
      end; (* if *)

    bufp := 0;
    for i := 1 to pad do
        unitwrite(oport,padchar,1);          (* write out any padding chars *)
    buffer[bufp] := chr(soh);                (* packet sync character *)
    bufp := bufp + 1;
    chksum := tochar(chr(len + 3));          (* init chksum *)
    buffer[bufp] := tochar(chr(len + 3));    (* character count *)
    bufp := bufp + 1;
    chksum := chr(ord(chksum) + ord(tochar(chr(num))));
    buffer[bufp] := tochar(chr(num));
    bufp := bufp + 1;
    chksum := chr(ord(chksum) + ord(ptype));
    buffer[bufp] := ptype;                   (* packet type *)
    bufp := bufp + 1;

    for i := 0 to len - 1 do                 (* loop through data chars *)
      begin
        buffer[bufp] := data[i];             (* store char *)
        bufp := bufp + 1;
        chksum := chr(ord(chksum) + ord(data[i]))
      end; (* for i *)
                                             (* compute final chksum *)
    chksum := chr(aand(ord(chksum) + (aand(ord(chksum),192) div 64), 63));
    buffer[bufp] := tochar(chksum);
    bufp := bufp + 1;
    buffer[bufp] := eol;

    if (parity <> nopar) then
        for i := 0 to bufp do                 (* set correct parity on buffer *)
            buffer[i] := parity_array[buffer[i]];

    unitwrite(oport,buffer[0],bufp+1);        (* send the packet out *)

    if debug then
        packetwrite(buffer,len);
  end; (* spack *)

function read_ch(*var q: queue; var ch: char): boolean*);

(* read a character from an input queue *)

  begin
    with q do
      begin
        if (inp <> outp) then            (* if a char there *)
          begin
            ch := data[outp];              (* get the char *)
            outp := (outp + 1) mod qsize1; (* increment buffer pointer *)
            read_ch := true;               (* and return true *)
          end (* if *)
        else                             (* otherwise *)
            read_ch := false;              (* return false *)
      end (* with *)
  end; (* read_ch *)

function getch(*var r: char_int_rec; var q: queue): boolean*);

(* gets a character, strips parity, returns true if it got a char which *)
(* isn't Kermit SOH, false if it gets SOH or nothing after maxtry *)

const maxtry = 10000;

var count: integer;

  begin
    count := 0;
    getch := false;
    with q do
      begin
        repeat
            count := count + 1;
        until (inp <> outp) or (count > maxtry);    (* wait for a character *)
        if (count > maxtry) then                    (* if wait too long then *)
            exit(getch);                              (* get out of here *)
        r.ch := data[outp];                         (* get the character *)
        outp := (outp + 1) mod qsize1;              (* increment pointer *)
        r.i := aand(r.i,127);                       (* strip parity from char *)
        getch := (r.ch <> chr(soh));                (* return true if not SOH *)
      end (* with *)
  end; (* getch *)

function getsoh(*var q: queue): boolean*);

(* reads characters until it finds an SOH; returns false if has to read more *)
(* than maxtry chars *)

const maxtry = 10000;

var ch: char;
    count: integer;

  begin
    count := 0;
    get_soh := true;
    with q do
      begin
        repeat
            repeat
                count := count + 1
            until (inp <> outp) or (count > maxtry); (* wait for a character *)
            if (count > maxtry) then
              begin
                get_soh := false;
                exit(get_soh)
              end; (* if *)
            ch := data[outp];                        (* get the character *)
            outp := (outp + 1) mod qsize1;           (* increment pointer *)
            ch := chr(aand(ord(ch),127));            (* strip parity of char *)
        until (ch = chr(SOH))                        (* if not SOH, get more *)
    end (* with q *)
  end; (* getsoh *)

(*$G+*) (* turn on goto option...need it for next routine *)

function rpack(*var len, num: integer; var data: packettype): char*);

(* read a packet *)

label 1; (* used to emulate C's CONTINUE statement *)

const maxtry = 10000;

var count, i, ichksum: integer;
    chksum, ptype: char;
    r: char_int_rec;

  begin
    count := 0;

    if not getsoh(rq) and (state<>'r') then (*if don't get synch char then *)
      begin
        rpack := 'N';                        (* treat as a NAK *)
        num := n mod 64;
        exit(rpack)                          (* and get out of here *)
      end;

  1: count := count + 1;
     if (count>maxtry)and(state<>'r') then (* if we've tried too many times *)
        begin                               (* and aren't waiting for init *)
          rpack := 'N';                      (* treat as NAK *)
          exit(rpack)                        (* and get out of here *)
        end; (* if *)

    if not getch(r,rq) then                (* get a char and *)
            goto 1;                        (* resynch if soh *)

    ichksum := r.i;                        (* start checksum *)
    len := ord(unchar(r.ch)) - 3;          (* character count *)

    if not getch(r,rq) then                (* get a char and *)
        goto 1;                            (* resynch if soh *)
    ichksum := ichksum + r.i;
    num := ord(unchar(r.ch));              (* packet number *)

    if not getch(r,rq) then                (* get a char and *)
        goto 1;                            (* resynch if soh *)
    ichksum := ichksum + r.i;
    ptype := r.ch;                         (* packet type *)

    for i := 0 to len-1 do                 (* get any data *)
      begin
        if not getch(r,rq) then            (* get a char and *)
            goto 1;                        (* resynch if soh *)
        ichksum := ichksum + r.i;
        data[i] := r.ch;
      end; (* for i *)
    data[len] := chr(0);                   (* mark end of data *)

    if not getch(r,rq) then                (* get a char and *)
        goto 1;                            (* resynch if soh *)

                                           (* compute final checksum *)
    chksum := chr(aand(ichksum + (aand(ichksum,192) div 64), 63));

    if (chksum <> unchar(r.ch)) then       (* if checksum bad *)
        rpack := chr(0)                      (* return 'false' indicator *)
    else                                   (* else *)
        rpack := ptype;                      (* return packet type *)

    if debug then
      begin
        gotoxy(0,debugline);
        write(len,num,ptype);
        for i := 1 to 1000 do
            ;
      end; (* if *)
  end; (* rpack *)

(*$G-*) (* turn off goto option...don't need it anymore *)

procedure connect;

(* connect to remote host (terminal emulation *)

var ch: char;
    close: boolean;

  procedure read_esc;

  (* read charcter after esc char and interpret it *)

    begin
      repeat
      until read_ch(kq,ch);       (* wait until they've typed something in *)
      if (ch in ['a'..'z']) then  (* uppercase it *)
          ch := chr(ord(ch) - ord('a') + ord('A'));
      if ch in ['B','C','S','?'] then
          case ch of
              'B': sendbrk;       (* B: send a break to the IBM *)
              'C': close := true; (* C: end connection *)
              'S': begin          (* S: show status *)
                  noun := allsym;
                  showparms
                end; (* S *)
              '?': begin          (* ?: show options *)
                  writeln('B    Send a BREAK signal.');
                  write('C    Close Connection, return to ');
                  writeln('KERMIT-UCSD command level.');
                  writeln('S    Show Status of connection');
                  writeln('?    Print this list');
                  write('^',esc_char,'   send the escape ');
                  writeln('character itself to the');
                  writeln('     remote host.')
                end; (* ? *)
            end (* case *)
      else if ch = esc_char then  (* ESC-char: send it out *)
        begin
          if half_duplex then
            begin
              echo(ch);
              unitwrite(oport,ch,1)
            end (* if *)
        end (* else if *)
      else                        (* anything else: ignore *)
          write(chr(bell))
    end; (* read_esc *)

  begin (* connect *)
    clear_buf(kq);                    (* empty keyboard buffer *)
    clear_buf(rq);                    (* empty remote input buffer *)
    writeln('Connecting to host...type CTRL-',ctl(esc_char),' C to exit');
    close := false;
    repeat
        if read_ch(rq,ch) then        (* if char from host then *)
            echo(ch);                   (* echo it *)

        if read_ch(kq,ch) then        (* if char from keyboard then *)
            if ch <> esc_char then      (* if not ESC-char then *)
              begin
                if half_duplex then       (* echo it if half-duplex *)
                    echo(ch);
                unitwrite(oport,ch,1)     (* send it out the port *)
              end (* if *)
            else (* ch = esc_char *)    (* else is ESC-char so *)
              read_esc;                   (* interpret next char *)
    until close;                      (* if still connected, get more *)
    writeln('Disconnected')
  end; (* connect *)

procedure fill_parity_array;

(* parity value table for even parity...not(entry) = odd parity *)

const min = 0;
      max = 126;

var i, shifter, counter: integer;
    minch, maxch, ch: char;
    r: char_int_rec;

  begin
    minch := chr(min);
    maxch := chr(max);
    case parity of
      evenpar:
        begin
          for ch := minch to maxch do
            begin
              r.ch := ch;               (* put char into variant record *)
              shifter := aand(r.i,255); (* mask off parity bit *)
              counter := 0;
              for i := 1 to 7 do        (* count the 1's *)
                begin
                  if odd(shifter) then
                      counter := counter + 1;
                  shifter := shifter div 2
                end; (* for i *)
              if odd(counter) then       (* stick a 1 on if necessary *)
                  parity_array[ch] := chr(aor(ord(ch),128))
              else
                  parity_array[ch] := chr(aand(ord(ch),127))
            end; (* for ch *)
        end; (* case even *)
      oddpar:
        begin
          for ch := minch to maxch do
            begin
              r.ch := ch;                (* put char into variant record *)
              shifter := aand(r.i,255);  (* mask off parity bit *)
              counter := 0;
              for i := 1 to 7 do         (* count the 1's *)
                begin
                  if odd(shifter) then
                      counter := counter + 1;
                  shifter := shifter div 2
                end; (* for i *)
              if odd(counter) then        (* stick a 1 on if necessary *)
                  parity_array[ch] := chr(aand(ord(ch),127))
              else
                  parity_array[ch] := chr(aor(ord(ch),128))
            end; (* for ch *)
        end; (* case odd *)
      markpar:
          for ch := minch to maxch do     (* stick a 1 on all chars *)
              parity_array[ch] := chr(aor(ord(ch),128));
      spacepar:
          for ch := minch to maxch do     (* mask off parity on all chars *)
              parity_array[ch] := chr(aand(ord(ch),127));
      nopar:
          for ch := minch to maxch do     (* don't mess w/parity bit at all *)
              parity_array[ch] := ch;
    end; (* case *)
  end; (* fill_parity_array *)

procedure write_bool(s: string; b: boolean);

(* writes message & 'on' if b, 'off' if not b *)
  begin
    write(s);
    case b of
        true: writeln('on');
        false: writeln('off');
      end; (* case *)
  end; (* write_bool *)

procedure show_parms;

(* shows the various settable parameters *)

  begin
    case noun of
        allsym:
          begin
            write_bool('Debugging is ',debug);
            writeln('Escape character is ^',ctl(esc_char));
            write_bool('File warning is ',fwarn);
            write_bool('IBM is ',ibm);
            write_bool('Local echo is ',halfduplex);
            case parity of
                evenpar: write('Even');
                markpar: write('Mark');
                nopar: write('No');
                oddpar: write('Odd');
                spacepar: write('Space');
              end; (* case *)
            writeln(' parity');
          end; (* allsym *)
        debugsym: write_bool('Debugging is ',debug);
        escsym: writeln('Escape character is ^',ctl(esc_char));
        filewarnsym: write_bool('File warning is ',fwarn);
        ibmsym: write_bool('IBM is ',ibm);
        localsym: write_bool('Local echo is ',halfduplex);
        paritysym: begin
            case parity of
                evenpar: write('Even');
                markpar: write('Mark');
                nopar: write('No');
                oddpar: write('Odd');
                spacepar: write('Space');
              end; (* case *)
            writeln(' parity');
           end; (* paritysym *)
      end; (* case *)
  end; (* show_sym *)

procedure set_parms;

(* sets the parameters *)

  begin
    case noun of
        debugsym: case adj of
                      onsym: begin
                          debug := true;
                          (*$I-*)
                          rewrite(debf,'CONSOLE:')
                          (*I+*)
                        end; (* onsym *)
                      offsym: debug := false
                    end; (* case adj *)
        escsym: escchar := newescchar;
        filewarnsym: fwarn := (adj = onsym);
        ibmsym: case adj of
                    onsym: begin
                        ibm := true;
                        parity := markpar;
                        half_duplex := true;
                        fillparityarray
                      end; (* onsym *)
                    offsym: begin
                        ibm := false;
                        parity := nopar;
                        half_duplex := false;
                        fillparityarray
                      end; (* onsym *)
                  end; (* case adj *)
        localsym: halfduplex := (adj = onsym);
        paritysym: begin
              case adj of
                  evensym: parity := evenpar;
                  marksym: parity := markpar;
                  nonesym: parity := nopar;
                  oddsym: parity := oddpar;
                  spacesym: parity := spacepar;
                end; (* case *)
              fill_parity_array;
             end; (* paritysym *)
      end; (* case *)
  end; (* set_parms *)

procedure initialize;

var ch: char;

  begin
    pad := mypad;
    padchar := chr(mypchar);
    eol := chr(my_eol);
    esc_char := chr(my_esc);
    quote := my_quote;
    ctlset := [chr(1)..chr(31),chr(del),quote];
    half_duplex := false;
    debug := false;
    fwarn := false;
    spsiz := max_pack;
    rpsiz := max_pack;
    n := 0;
    parity := nopar;
    initvocab;
    fill_parity_array;
    ibm := false;
    xon := chr(17);
    bufpos := 1;
    bufend := 0;
    rcvinit(rq,rqsize);
    kbdinit(kq,rqsize);
  end; (* initialize *)

procedure closeup;

  begin
    kbdfinit;
    rcvfinit;
    writeln(chr(clear_screen))
  end; (* closeup *)

  begin (* kermit *)
    initialize;
    repeat
        write('Kermit-UCSD> ');
        readstr(kq,line);
        case parse of
            unconfirmed: writeln('Unconfirmed');
            parm_expected: writeln('Parameter expected');
            ambiguous: writeln('Ambiguous');
            unrec: writeln('Unrecognized command');
            fn_expected: writeln('File name expected');
            ch_expected: writeln('Single character expected');
            null: case verb of
                      consym: connect;
                      helpsym: help;
                      recsym: begin
                          recsw(rec_ok);
                          gotoxy(0,debugline);
                          write(chr(bell));
                          if rec_ok then
                              writeln('successful receive')
                          else
                              writeln('unsuccessful receive');
                          (*$I-*) (* set i/o checking off *)
                          close(oldf);
                          (*$I+*) (* set i/o checking back on *)
                          gotoxy(0,promptline);
                        end; (* recsym *)
                      sendsym: begin
                          uppercase(filename);
                          sendsw(send_ok);
                          gotoxy(0,debugline);
                          write(chr(bell));
                          if send_ok then
                              writeln('successful send')
                          else
                              writeln('unsuccessful send');
                          (*$I-*) (* set i/o checking off *)
                          close(oldf);
                          (*$I+*) (* set i/o checking back on *)
                          gotoxy(0,promptline);
                        end; (* sendsym *)
                      setsym: set_parms;
                      show_sym: show_parms;
                  end; (* case verb *)
        end; (* case parse *)
     until (verb = exitsym) or (verb = quitsym);
     closeup
   end. (* kermit *)
>>>> PARSER.TEXT
(*$S+*)
unit parser;

INTERFACE

type statustype = (null, at_eol, unconfirmed, parm_expected, ambiguous,
                   unrec, fn_expected, ch_expected);
     vocab = (nullsym, allsym, consym, debugsym, escsym, evensym, exitsym,
              filewarnsym,helpsym, ibmsym, localsym, marksym, nonesym,
              oddsym, offsym, onsym, paritysym, quitsym, recsym, sendsym,
              setsym, showsym, spacesym);

var noun, verb, adj: vocab;
    status: statustype;
    vocablist: array[vocab] of string;
    filename, line: string;
    newescchar: char;
    expected: set of vocab;

procedure uppercase(var s: string);

function parse: statustype;

procedure initvocab;

IMPLEMENTATION

procedure uppercase(*var s: string*);

var i: integer;

  begin
    for i := 1 to length(s) do
        if s[i] in ['a'..'z'] then
            s[i] := chr(ord(s[i]) - ord('a') + ord('A'))
  end; (* uppercase *)

procedure eatspaces(var s: string);

var done: boolean;
    i: integer;

  begin
    done := (length(s) = 0);
    while not done do
      begin
        if s[1] = ' ' then
          begin
            i := length(s) - 1;
            s := copy(s,2,i);
            done := length(s) = 0
          end (* if *)
        else
            done := true
      end (* while *)
  end; (* eatspaces *)

procedure isolate_word(var line, s: string);

var i: integer;
    done: boolean;

  begin
    done := false;
    i := 1;
    s := copy(' ',0,0);
    while (i <= length(line)) and not done do
      begin
        if line[i] = ' ' then
            done := true
        else
            s := concat(s,copy(line,i,1));
        i := i + 1;
      end; (* while *)
    line := copy(line,i,length(line)-i+1);
  end; (* isolate_word *)

function get_fn(var line, fn: string): boolean;

var i, l: integer;

  begin
    get_fn := true;
    isolate_word(line, fn);
    l := length(fn);
    if (l < 1) then
        get_fn := false
  end; (* get_fn *)

function getch(var ch: char): boolean;

var s: string;

  begin
    isolate_word(line,s);
    if length(s) <> 1 then
        getch := false
    else
      begin
        ch := s[1];
        get_ch := true
      end (* else *)
  end; (* getch *)

function parse(*: statustype*);

type states = (start, fin, get_filename, get_set_parm, get_parity, get_on_off,
               get_char, get_show_parm, get_help_show, get_help_parm,
               exitstate);

var status: statustype;
    word: vocab;
    state: states;

function get_sym(var word: vocab): statustype;

var i: vocab;
    s: string;
    stat: statustype;
    done: boolean;
    matches: integer;

  begin
    eat_spaces(line);
    if length(line) = 0 then
        getsym := ateol
    else
      begin
        stat := null;
        done := false;
        isolate_word(line,s);
        i := allsym;
        matches := 0;
        repeat
            if (pos(s,vocablist[i]) = 1) and (i in expected) then
              begin
                matches := matches + 1;
                word := i
              end
            else if (s[1] < vocablist[i,1]) then
                done := true;
            if (i = spacesym) then
                done := true
            else
                i := succ(i)
        until (matches > 1) or done;
        if matches > 1 then
            stat := ambiguous
        else if (matches = 0) then
            stat := unrec;
        getsym := stat
      end (* else *)
  end; (* getsym *)

  begin
    state := start;
    parse := null;
    noun := nullsym;
    verb := nullsym;
    adj := nullsym;
    uppercase(line);
    repeat
        case state of
          start:
              begin
                expected := [consym, exitsym, helpsym, quitsym, recsym, sendsym,
                             setsym, showsym];
                status := getsym(verb);
                if status = ateol then
                  begin
                    parse := null;
                    exit(parse)
                  end (* if *)
                else if (status <> unrec) and (status <>  ambiguous) then
                    case verb of
                      consym: state := fin;
                      exitsym, quitsym: state := fin;
                      helpsym: state := get_help_parm;
                      recsym: state := fin;
                      sendsym: state := getfilename;
                      setsym: state := get_set_parm;
                      showsym: state := get_show_parm;
                    end (* case *)
              end; (* case start *)
          fin:
              begin
                expected := [];
                status := getsym(verb);
                if status = ateol then
                  begin
                    parse := null;
                    exit(parse)
                  end (* if status *)
                else
                    status := unconfirmed
              end; (* case fin *)
          getfilename:
            begin
              expected := [];
              if getfn(line,filename) then
                begin
                  status := null;
                  state := fin
                end (* if *)
              else
                  status := fnexpected
            end; (* case get file name *)
          get_set_parm:
              begin
                expected := [paritysym, localsym, ibmsym, escsym,
                             debugsym, filewarnsym];
                status := getsym(noun);
                if status = ateol then
                    status := parm_expected
                else if (status <> unrec) and (status <>  ambiguous) then
                    case noun of
                      paritysym: state := get_parity;
                      localsym: state := get_on_off;
                      ibmsym: state := get_on_off;
                      escsym: state := getchar;
                      debugsym: state := getonoff;
                      filewarnsym: state := getonoff;
                    end (* case *)
            end; (* case get_set_parm *)
          get_parity:
              begin
                expected := [marksym, spacesym, nonesym, evensym, oddsym];
                status := getsym(adj);
                if status = ateol then
                    status := parm_expected
                else if (status <> unrec) and (status <> ambiguous) then
                    state := fin
              end; (* case get_parity  *)
          get_on_off:
              begin
                expected := [onsym, offsym];
                status := getsym(adj);
                if status = ateol then
                    status := parm_expected
                else if (status <> unrec) and (status <> ambiguous) then
                    state := fin
              end; (* get_on_off *)
          get_char:
              if getch(newescchar) then
                 state := fin
              else
                 status := ch_expected;
          get_show_parm:
              begin
                expected := [allsym, paritysym, localsym, ibmsym, escsym,
                             debugsym, filewarnsym];
                status := getsym(noun);
                if status = ateol then
                    status := parm_expected
                else if (status <> unrec) and (status <>  ambiguous) then
                    state := fin
              end; (* case get_show_parm *)
          get_help_show:
              begin
                expected := [paritysym, localsym, ibmsym, escsym,
                           debugsym, filewarnsym];
                status := getsym(adj);
                if (status = at_eol) then
                  begin
                    status := null;
                    state := fin
                  end
                else if (status <> unrec) and (status <>  ambiguous) then
                    state := fin
              end; (* case get_help_show *)
          get_help_parm:
              begin
                expected := [consym, exitsym, helpsym, quitsym, recsym,
                             sendsym, setsym, showsym];
                status := getsym(noun);
                if status = ateol then
                  begin
                    parse := null;
                    exit(parse)
                  end;
                if (status <> unrec) and (status <>  ambiguous) then
                    case noun of
                      consym: state := fin;
                      sendsym: state := fin;
                      recsym: state := fin;
                      setsym: state := get_help_show;
                      showsym: state := fin;
                      helpsym: state := fin;
                      exitsym, quitsym: state := fin;
                    end (* case *)
              end; (* case get_help_show *)
        end (* case *)
    until (status <> null);
    parse := status
  end; (* parse *)

procedure initvocab;

var i: integer;

  begin
    vocablist[allsym] := 'ALL';
    vocablist[consym] := 'CONNECT';
    vocablist[debugsym] := 'DEBUG';
    vocablist[escsym] := 'ESCAPE';
    vocablist[evensym] := 'EVEN';
    vocablist[exitsym] := 'EXIT';
    vocablist[filewarnsym] := 'FILE-WARNING';
    vocablist[helpsym] := 'HELP';
    vocablist[ibmsym] := 'IBM';
    vocablist[localsym] := 'LOCAL-ECHO';
    vocablist[marksym] := 'MARK';
    vocablist[nonesym] := 'NONE';
    vocablist[oddsym] := 'ODD';
    vocablist[offsym] := 'OFF';
    vocablist[onsym] := 'ON';
    vocablist[paritysym] := 'PARITY';
    vocablist[quitsym] := 'QUIT';
    vocablist[recsym] := 'RECEIVE';
    vocablist[sendsym] := 'SEND';
    vocablist[setsym] := 'SET';
    vocablist[showsym] := 'SHOW';
    vocablist[spacesym] := 'SPACE';
  end; (* initvocab *)

  end. (* end of unit *)
>>>> RCVHANDLR.TEXT
;                        ----------------------------
;                        RCVHNDLR TTY Receive Handler
;                        ----------------------------
;
;    Two routines are provided that maintain an interrupt-driven
;    TTY-receive queue.  Appropriate PASCAL declarations are:
;
;        CONST RCVQSIZE = maximum number of queued characters
;
;        TYPE QUEUE = RECORD    (* These are order-dependent !!! *)
;                       QSIZE: INTEGER;
;                       INP: INTEGER;
;                       OUTP: INTEGER;
;                       MAXCHAR: INTEGER;
;                       DATA: PACKED ARRAY [0..RCVQSIZE] OF CHAR;
;                     END;
;        VAR RCVQ: QUEUE;     (* must be declared in outermost block *)
;
;        PROCEDURE RCVINIT (VAR Q: QUEUE; SIZE:INTEGER); EXTERNAL;
;        PROCEDURE RCVFINIT; EXTERNAL;
;
;        RCVINIT (RCVQ,RCVQSIZE);    (* initialize the queue handler *)
;
;        WHILE TRUE DO
;          WITH RCVQ DO
;           IF INP <> OUTP THEN    (* characters available *)
;             BEGIN
;               CH := DATA[OUTP];
;               OUTP := OUTP+1; IF OUTP > QSIZE THEN OUTP := 0;
;                ...
;             END;
;
;        RCVFINIT;       (* terminate the queue handler *)
;
;    The RECORD declaration for the queue must appear exactly as it
;    does above except that you can of course use any names you like.
;    Do NOT attempt to lump the first four integer variables together
;    into a single group of the form list:INTEGER.  In that case,
;    the compiler allocates them in reverse order, so that your code
;    and the interrupt handler will not agree about which words have
;    what meaning.
;
;    The queue handler runs continuously as an interrupt-driven task
;    at high priority.  As characters come in, it advances the queue
;    INP pointer and keeps track of the maximum number of characters in
;    the queue in the MAXCHAR variable.  Queue overflow is indicated
;    by MAXCHAR > QSIZE.  You must terminate by calling RCVFINIT, or
;    the TTY receive interrupts will be left enabled and you will end
;    up crashing the system by executing garbage code when the next
;    character is received.  (RCVFINIT also repairs the interrupt
;    vectors for breakpoints and the clock, so failing to call it will
;    quite likely crash the system even in the absence of incoming
;    TTY characters.)
;
;    The manipulation of the clock and BPT interrupt vectors is borrowed
;    from UCSD's old communications program.  The purpose is to allow
;    the clock handler to be interrupted by incoming TTY characters.
;
RDB       .EQU   177522          ; Receive Data Buffer absolute address
RSR       .EQU   177520          ; Receive Status Register absolute address
RCVINTV   .EQU      120          ; Receiver Interrupt Vector address
CLKINTV   .EQU      100          ; Clock interrupt vector address
BPTINTV   .EQU       14          ; BPT interrupt vector address
QXCINTV   .EQU      250          ; QX controller interrupt vector
;
          .PROC  RCVINIT,2       ; (VAR Q:QUEUE, SIZE:INTEGER)
;
          .DEF   BPTLOC          ; used to save BPT interrupt handler adrs
          .DEF   BPTPR           ; used to save BPT handler priority
Q         .EQU   4               ; stack offset for Q address
SIZE      .EQU   2               ; stack offset for QSIZE value
;
          MOV    Q(SP),R0        ; obtain the Q record address
          MOV    R0,RCVQADRS     ; remember Q address
          MOV    SIZE(SP),(R0)+  ; store size in QSIZE word
          MOV    #0,(R0)+        ; clear INP, OUTP, and MAXCHAR
          MOV    #0,(R0)+
          MOV    #0,(R0)
;
          MOV    @#BPTINTV,BPTLOC    ; save old BPT handler address
          MOV    @#BPTINTV+2,BPTPR   ; and old BPT handler priority
          MOV    @#CLKINTV,@#BPTINTV ; make BPT vector point to old clock
          MOV    #0,@#BPTINTV+2      ; and let it run at low priority
          MOV    #CLKHNDLR,@#CLKINTV ; and replace clock handler with ours
          MOV    #0,@#QXCINTV+2      ; make floppy interruptable
;
          MOV    #RCVHNDLR,@#RCVINTV ; store interrupt handler address
          MOV    #200,@#RCVINTV+2    ; set interrupt priority 4 for TTY input
          MOV    #100,@#RSR          ; enable interrupts for TTY input
;
          MOV    (SP)+,R0        ; pop return address from stack
          ADD    #4,SP           ; discard 2 parameters (4 bytes)
          JMP    @R0             ; and return to PASCAL interpreter
;
RCVQADRS  .WORD   0              ; holds Q address for handler
BPTLOC    .WORD   0              ; saves old BPT handler location
BPTPR     .WORD   0              ; saves old BPT handler priority
;
QSIZE     .EQU    0              ; offset from Q
INP       .EQU    2              ; likewise
OUTP      .EQU    4
MAXCHAR   .EQU    6
DATA      .EQU   10
;
RCVHNDLR: MOV    R0,-(SP)        ; free registers R0, R1, R2 for use
          MOV    R1,-(SP)
          MOV    R2,-(SP)
          MOV    RCVQADRS,R2     ; fetch Q address saved by RCVINIT
          MOV    INP(R2),R0      ; fetch INP value
          MOV    R0,R1           ; make a working copy
          ADD    R2,R1           ; R1 = address (Q) + value (INP)
          MOVB   @#RDB,DATA(R1)  ; DATA[INP] := input character
          BICB   #200,DATA(R1)   ; clear bit 8 (parity)
          BEQ    EXIT            ; ignore nulls (do not bump INP)
          INC    R0              ; INP := INP+1
          CMP    QSIZE(R2),R0
          BPL    NOWRAP          ; if QSIZE >= INP then no wraparound
          CLR    R0              ; else INP := 0
NOWRAP    MOV    R0,INP(R2)      ; restore INP
;
          SUB    OUTP(R2),R0
          BMI    INOUT
          BEQ    INOUT
          BR     OUTIN           ; if INP > OUTP, # char = INP - OUTP
INOUT     ADD    QSIZE(R2),R0    ; otherwise, # char = QSIZE+1 + INP - OUTP
          ADD    #1,R0
OUTIN     CMP    MAXCHAR(R2),R0
          BPL    EXIT            ; if MAXCHAR >= # char, exit
          MOV    R0,MAXCHAR(R2)  ; otherwise, store new MAXCHAR
;
EXIT      MOV    (SP)+,R2        ; restore registers for caller
          MOV    (SP)+,R1
          MOV    (SP)+,R0
          RTT                    ; return from interrupt
;
CLKHNDLR: COM    CLKFLG          ; do not reexecute BPT if BPT handler
          BEQ    CLKEXIT         ;   takes so long that clock ticks again
          BPT                    ; let breakpoint transfer to old clock
CLKEXIT   COM    CLKFLG          ; reset flag
          RTI                    ; and exit
;
CLKFLG    .WORD  0               ; flags reentry before BPT exit
;
          .PROC  RCVFINIT
          .REF   BPTLOC          ; old BPT handler loc, saved by RCVINIT
          .REF   BPTPR           ; old BPT handler priority, likewise
;
          MOV    #0,@#RSR             ; disable receive interrupt
          MOV    @#BPTINTV,@#CLKINTV  ; repair clock interrupt vector
          MOV    @#BPTPR,@#BPTINTV+2  ; reestablish BPT handler priority
          MOV    @#BPTLOC,@#BPTINTV   ; repair BPT handler address
          MOV    #340,@#QXCINTV+2     ; repair QX controller vector
          RTS    PC                   ; and return
;
          .END

>>>> RECSW.TEXT

(* RECEIVE SECTION *)

segment procedure recsw(var rec_ok: boolean);

function rdata: char;

(* send file data *)

var num, len: integer;
    ch: char;

  begin

    repeat
        if numtry > maxtry then
          begin
            state := 'a';
            exit(rdata)
          end;

        num_try := num_try + 1;

        ch := rpack(len,num,recpkt);   (* receive a packet *)

        refresh_screen(numtry,n);

        if (ch = 'D') then             (* got data packet *)
          begin
            if (num <> (n mod 64)) then (* wrong packet *)
              begin
                if (oldtry > maxtry) then
                  begin
                    rdata := 'a';      (* too many tries, abort *)
                    exit(rdata)
                  end; (* if *)

                n := n - 1;

                if (num = (n mod 64)) then (* previous packet again *)
                  begin                (* so re-ACK it *)
                    spack('Y',num,6,packet);
                    numtry := 0;       (* reset try counter *)
                                       (* stay in same state *)
                  end (* if *)
                else                   (* wrong number *)
                    state := 'a'       (* so abort *)
              end (* if *)
            else                       (* right packet *)
              begin
                bufemp(recpkt,f,len);  (* write data to file *)
                spack('Y',(n mod 64),0,packet); (* ACK packet *)
                oldtry := numtry;      (* reset try counters *)
                if numtry > 1 then
                    clearbuf(rq);      (* clear buffer *)
                numtry := 0;
                n := n + 1             (* bump packet number *)
                                       (* stay in data send state *)
              end (* else *)
          end (* if 'D' *)
        else if (ch = 'F') then        (* file header *)
          begin
            if (oldtry > maxtry) then
              begin
                rdata := 'a';          (* too many tries, abort *)
                exit(rdata)
              end; (* if *)

            n := n - 1;

            if (num = (n mod 64)) then (* previous packet again *)
              begin                    (* so re-ACK it *)
                spack('Y',num,0,packet);
                clear_buf(rq);         (* and empty out buffer *)
                numtry := 0;           (* reset try counter *)
                state := state;        (* stay in same state *)
              end (* if *)
            else
                state := 'a'           (* not previous packet, abort *)
          end (* if 'F' *)
        else if (ch = 'Z') then        (* end of file *)
          begin
            if (num <> (n mod 64)) then(* wrong packet, abort *)
              begin
                rdata := 'a';
                exit(rdata)
              end; (* if *)
            spack('Y',n mod 64,0,packet); (* ok, ACK it *)
            close(f,lock);             (* close up the file *)
            n :=  n + 1;               (* bump packet counter *)
            state := 'f';              (* go to complete state *)
          end (* else if 'Z' *)
        else if (ch = 'E') then        (* error packet *)
          begin
            error(recpkt,len);         (* display error *)
            state := 'a'               (* and abort *)
          end (* if 'E' *)
        else if (ch <> chr(0)) then    (* some other packet type, *)
            state := 'a'               (* abort *)
    until (state <> 'd');
    rdata := state
  end; (* rdata *)

function rfile: char;

(* receive file header *)

var num, len: integer;
    ch: char;
    oldfn: string;
    i: integer;

procedure makename(recpkt: packettype; var fn: string; l: integer);

function exist(fn: string): boolean;

(* returns true if file named fn exists *)

var f: file;

  begin
    (*$I-*) (* turn off i/o checking *)
    reset(f,fn);
    exist := (ioresult = 0)
    (*$I+*)
  end; (* exist *)

procedure checkname(var fn: string);

(* if file fn exists, makes a new name which doesn't *)
(* does this by changing letters in file name until it *)
(* finds some combination which doesn't exitst *)

var ch: char;
    i: integer;

  begin
    i := 1;
    while (i <= length(fn)) and exist(fn) do
      begin
        ch := 'A';
        while (ch in ['A'..'Z']) and exist(fn) do
          begin
            fn[i] := ch;
            ch := succ(ch);
          end; (* while *)
        i := i + 1
      end; (* while *)
    end; (* checkname *)

  begin (* makename *)
    fn := copy('               ',1,15);    (* stretch length *)
    moveleft(recpkt[0],fn[1],l);           (* get filename from packet *)
    oldfn := copy(fn, 1,l);                (* save fn sent to show user *)
    fn := copy(fn,1,min(15,l));            (* set length of filename *)
                                           (* and make sure <= 15 *)
    uppercase(fn);
    if pos('.TEXT',fn) <> length(fn)-4 then
      begin
        if length(fn) > 10 then
            fn := copy(fn,1,10);           (* can only be 15 long in all *)
        fn := concat(fn,'.TEXT');          (* and we'll add .TEXT *)
      end; (* if *)
    if fwarn then                          (* if file warning is on *)
        checkname(fn);                       (* must check that name unique *)
  end; (* makename *)

  begin (* rfile *)
    if debug then
        debugwrite('rfile');

    if (numtry > maxtry) then         (* if too many tries, give up *)
      begin
        rfile := 'a';
        exit(rfile)
      end;
    numtry := numtry + 1;

    ch := rpack(len,num,recpkt);      (* receive a packet *)

    refresh_screen(numtry,n);

    if ch = 'S' then                  (* send init, maybe our ACK lost *)
      begin
        if (oldtry > maxtry) then     (* too many tries, abort *)
          begin
            rfile := 'a';
            exit(rfile)
          end; (* if *)

        n := n - 1;

        if num = (n mod 64) then      (* previous packet mod 64? *)
          begin                       (* yes, ACK it again *)
            spar(packet);             (* with our send init params *)
            spack('Y',num,6,packet);
            numtry := 0;              (* reset try counter *)
            rfile := state;           (* stay in same state *)
          end (* if *)
        else                          (* not previous packet, abort *)
          state := 'a'
      end (* if 'S' *)
    else if (ch = 'Z') then           (* end of file *)
      begin
        if (oldtry > maxtry) then     (* too many tries, abort *)
          begin
            rfile := 'a';
            exit(rfile)
          end; (* if *)

        n := n - 1;

        if num = (n mod 64) then       (* previous packet mod 64? *)
          begin                       (* yes, ACK it again *)
            spack('Y',num,0,packet);
            numtry := 0;
            rfile := state            (* stay in same state *)
          end (* if *)
        else
            rfile := 'a'              (* no, abort *)
      end (* else if *)
    else if (ch = 'F') then           (* file header *)
      begin                           (* which is what we really want *)
        if (num <> (n mod 64)) then   (* if wrong packet, abort *)
          begin
            rfile := 'a';
            exit(rfile)
          end;

        makename(recpkt,filename,len); (* get filename, make unique if filew *)
        gotoxy(filepos,fileline);
        write(oldfn,' ==> ',filename);

        if not getfil(filename) then  (* try to open new file *)
          begin
            ioerror(ioresult);        (* if unsuccessful, tell them *)
            rfile := 'a';             (* and abort *)
            exit(rfile)
          end; (* if *)

        spack('Y',n mod 64,0,packet); (* ACK file header *)
        oldtry := numtry;             (* reset try counters *)
        numtry := 0;
        n := n + 1;                   (* bump packet number *)
        rfile := 'd';                 (* switch to data state *)
      end (* else if *)
    else if ch = 'B' then             (* break transmission *)
      begin
        if (num <> (n mod 64)) then            (* wrong packet, abort *)
          begin
            rfile := 'a';
            exit(rfile)
          end;
        spack('Y',n mod 64,0,packet); (* say ok *)
        rfile := 'c'                  (* go to complete state *)
      end (* else if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        rfile := 'a'
      end
    else if (ch = chr(0)) then        (* returned false *)
        rfile := state                (* so stay in same state *)
    else                              (* some weird state, so abort *)
        rfile := 'a'
  end; (* rfile *)

function rinit: char;

(* receive initialization *)

var num, len: integer;  (* packet number and length *)
    ch: char;

  begin
    if debug then
        debugwrite('rinit');

    numtry := numtry + 1;

    ch := rpack(len,num,recpkt); (* receive a packet *)
    refresh_screen(num_try,n);

    if (ch = 'S') then           (* send init packet *)
      begin
        rpar(recpkt);            (* get other side's init data *)
        spar(packet);            (* fill packet with my init data *)
        ctl_set := [chr(1)..chr(31),chr(del),quote];
        spack('Y',n mod 64,6,packet); (* ACK with my params *)
        oldtry := numtry;        (* save old try count *)
        numtry := 0;             (* start a new counter *)
        n := n + 1;              (* bump packet number *)
        rinit := 'f';            (* enter file send state *)
      end (* if 'S' *)
    else if (ch = 'E') then
      begin
        rinit := 'a';
        error(recpkt,len)
      end (* if 'E' *)
    else if (ch = chr(0)) then
        rinit := 'r'             (* stay in same state *)
    else
        rinit := 'a'             (* abort *)
  end; (* rinit *)

(* state table switcher for receiving packets *)

  begin (* recswok *)
    writescreen('Receiving');
    state := 'r';            (* initial state is send *)
    n := 0;                  (* set packet # *)
    numtry := 0;             (* no tries yet *)

    while true do
        if state in ['d', 'f', 'r', 'c', 'a'] then
          case state of
              'd': state := rdata;
              'f': state := rfile;
              'r': state := rinit;
              'c': begin
                     rec_ok := true;
                     exit(recsw)
                   end; (* case c *)
              'a': begin
                     rec_ok := false;
                     exit(recsw)
                   end (* case a *)
            end (* case *)
        else (* state not in legal states *)
          begin
            rec_ok := false;
            exit(recsw)
          end (* else *)
  end; (* recsw *)

>>>> SENDB.TEXT
;                    ------------------------------
;                    .  SENDS TTY Output Routine  .
;                    ------------------------------
;
;     SENDBRK is a routine to send a continuous break to an IBM mainframe.
;     The appropriate PASCAL declaration is:
;
;         PROCEDURE SENDBRK; EXTERNAL;  (*to send a break*)
;
;
XDB       .EQU   177526        ; absolute address, transmit data buffer
XSR       .EQU   177524        ; absolute address, transmit status register
;
;
          .PROC  SENDBRK
;
SNDB1:    BIT    #200,@#XSR    ; wait for previous char to complete
          BEQ    SNDB1
;
          MOV    #1,@#XSR      ; transmit continuous break
          MOV    #310,R1       ; wait 200 (=310 octal) milliseconds
SNDB2:    MOV    #124,R0
SNDB3:    SUB    #1,R0
          BNE    SNDB3
          SUB    #1,R1
          BNE    SNDB2
          MOV    #0,@#XSR      ; clear continuous break
;
          RTS    PC            ; and return
;
          .END

>>>> SENDSW.TEXT

(* Send Section *)

segment procedure sendsw(var send_ok: boolean);

var io_status: integer;

procedure openfile;

(* resets file & gets past first 2 blocks *)

  begin
    (*$I-*) (* turn off compiler i/o checking temporarily *)
    reset(oldf,filename);
    (*$I+*) (* turn compiler i/o checking back on *)
    io_status := io_result;
    if (iostatus = 0) then
      if (pos('.TEXT',filename) = length(filename) - 4) then
                                          (* is a text file, so *)
          i := blockread(oldf,filebuf,2); (* skip past 2 block header *)
  end; (* openfile *)

function sinit: char;

(* send init packet & receive other side's *)

var num, len, i: integer;  (* packet number and length *)
    ch: char;

  begin
    if debug then
        debugwrite('sinit');

    if numtry > maxtry then
      begin
        sinit := 'a';
        exit(sinit)
      end;

    num_try := num_try + 1;
    spar(packet);

    clear_buf(rq);

    refresh_screen(numtry,n);

    spack('S',n mod 64,6,packet);

    ch := rpack(len,num,recpkt);

    if (ch = 'N') then
      begin
        sinit := 's';
        exit(sinit)
      end (* if 'N' *)
    else if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then       (* not the right ack *)
          begin
            sinit := state;
            exit(sinit)
          end;
        rpar(recpkt);
        if (eol = chr(0)) then   (* if they didn't spec eol *)
            eol := chr(my_eol);    (* use mine *)
        if (quote = chr(0)) then (* if they didn't spec quote *)
            quote := my_quote;     (* use mine *)
        ctl_set := [chr(1)..chr(31),chr(del),quote];
        numtry := 0;
        n := n + 1;              (* increase packet number *)
        sinit := 'f';
        exit(sinit)
      end (* else if 'Y' *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sinit := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then
        sinit := state
    else if (ch <> 'N') then
        sinit := 'a'
  end; (* sinit *)

function sdata: char;

(* send file data *)

var num, len: integer;
    ch: char;
    packarray: array[false..true] of packettype;
    sizearray: array[false..true] of integer;
    current: boolean;
    b: boolean;

function other(b: boolean): boolean;

(* complements a boolean which is used as array index *)

  begin
    if b then
        other := false
    else
        other := true
  end; (* other *)

  begin
    current := true;
    packarray[current] := packet;
    sizearray[current] := size;
    while (state = 'd') do
      begin
        if (numtry > maxtry) then             (* if too many tries, give up *)
            state := 'a';

        b := other(current);
        numtry := numtry + 1;

                                          (* send a data packet *)
        spack('D',n mod 64,sizearray[current],packarray[current]);

        refresh_screen(numtry,n);
                                          (* set up next packet *)
        sizearray[b] := bufill(packarray[b]);

        ch := rpack(len,num,recpkt);      (* receive a packet *)
        if ch = 'N' then                  (* NAK, so just stay in this state *)
            if ((n+1) mod 64 <> num) then (* unless NAK for next, which *)
                sdata := state
            else                          (* is just like ACK for this packet *)
              begin
                if num > 0 then
                    num := (num - 1)      (* in which case, decrement num *)
                else
                    num := 63;
                ch := 'Y';                (* and indicate an ACK *)
              end; (* else *)

        if (ch = 'Y') then
           begin
             if ((n mod 64) <> num) then (* if wrong ACK *)
               begin
                 sdata := state;         (* stay in same state *)
                 exit(sdata);            (* get out of here *)
               end; (* if *)
             if numtry > 1 then
                 clear_buf(rq);          (* if anything in buffer, flush it *)
             numtry := 0;
             n := n + 1;
             current := b;
             if sizearray[current] = ateof then
                 state := 'z'            (* set state to eof *)
             else
                 state := 'd'            (* else stay in data state *)
           end (* if *)
          else if (ch = 'E') then
            begin
              error(recpkt,len);
              state := 'a'
            end (* if 'E' *)
          else if (ch = chr(0)) then      (* receive failure, so stay in d *)
            begin
            end
          else if (ch <> 'N') then
            state := 'a'                  (* on any other goto abort state *)
      end; (* while *)
    size := sizearray[current];
    packet := packarray[current];
    sdata := state
  end; (* sdata *)

function sfile: char;

(* send file header *)

var num, len, i: integer;
    ch: char;
    fn: packettype;
    oldfn: string;

procedure legalize(var fn: string);

(* make sure file name will be legal to other computer *)

var count, i, j, l: integer;

procedure uppercase(var s: string);

var i: integer;

  begin
    for i := 1 to length(s) do
        if s[i] in ['a'..'z'] then
            s[i] := chr(ord('A') + ord(s[i]) - ord('a'))
  end; (* uppercase *)

  begin
    count := 0;
    l := length(fn);
    for i := 1 to l do                                  (* count '.'s in fn *)
        if fn[i] = '.' then
            count := count + 1;
    for i := 1 to count-1 do                            (* remove all but 1 *)
      begin
        j := 1;
        while (j < l) and (fn[j] <> '.') do
            j := j + 1;
            delete(fn,j,1);l := l - 1
      end; (* for i *)
    l := length(fn);
    i := pos(':',fn);
    if (i <> 0) then
      begin
        fn := copy(fn,i,l-i);
        l := length(fn)
      end;
    i := 1;
    while (i <= length(fn)) do
        if not(fn[i] in ['a'..'z','A'..'Z','.','0'..'9']) then
            delete(fn,i,1)
        else
            i := i + 1;
    uppercase(fn)
  end; (* legalize *)

  begin
    if debug then
        debugwrite('sfile');

    if (numtry > maxtry) then          (* if too many tries, give up *)
      begin
        sfile := 'a';
        exit(sfile)
      end;
    numtry := numtry + 1;

    oldfn := filename;
    legalize(filename);                (* make filename acceptable to remote *)
    len := length(filename);

    moveleft(filename[1],fn[0],len);   (* move filename into a packettype *)

    gotoxy(filepos,fileline);
    write(oldfn,' ==> ',filename);

    refresh_screen(numtry,n);

    spack('F',n mod 64,len,fn);               (* send file header packet *)

    size := bufill(packet);            (* get first data from file *)
                                       (* while waiting for response *)

    ch := rpack(len,num,recpkt);
    if ch = 'N' then                   (* NAK, so just stay in this state *)
        if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
            exit(sfile)                (* is just like ACK for this packet *)
        else
          begin
            if (num > 0) then
                num := (num - 1)       (* in which case, decrement num *)
            else
                num := 63;
            ch := 'Y';                 (* and indicate an ACK *)
          end; (* else *)

    if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then  (* if wrong ACK, stay in F state *)
            exit(sfile);
        numtry := 0;
        n := n + 1;
        sfile := 'd';
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sfile := 'a'
      end (* if 'E' *)
    else if (ch <> chr(0)) and (ch <> 'N') then (* don't recognize it *)
        sfile := 'a'
  end; (* sfile *)

function seof: char;

(* send end of file *)

var num, len: integer;
    ch: char;

  begin
    if debug then
        debugwrite('seof');

    if (numtry > maxtry) then          (* if too many tries, give up *)
      begin
        seof := 'a';
        exit(seof)
      end;
    numtry := numtry + 1;

    refresh_screen(numtry,n);

    spack('Z',(n mod 64),0,packet);    (* send end of file packet *)

    if debug then
        debugwrite('seof1');

    ch := rpack(len,num,recpkt);
    if ch = 'N' then                   (* NAK, so just stay in this state *)
        if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
            exit(seof)                 (* is just like ACK for this packet *)
        else
          begin
            if num > 0 then
                num := (num - 1)       (* in which case, decrement num *)
            else
                num := 63;
            ch := 'Y';                 (* and indicate an ACK *)
          end; (* else *)

    if (ch = 'Y') then
      begin
        if debug then
            debugwrite('seof2');
        if ((n mod 64) <> num) then     (* if wrong ACK, stay in F state *)
            exit(seof);
        numtry := 0;
        n := n + 1;
        if debug then
            debugwrite(concat('closing ',s));
        close(oldf);
        seof := 'b'
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        seof := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then         (* receive failed, so stay in z state *)
      begin
      end
    else if (ch <> 'N') then           (* other error, just abort *)
        seof := 'a'
  end; (* seof *)

function sbreak: char;

var num, len: integer;
    ch: char;

(* send break (end of transmission) *)

  begin
    if debug then
        debugwrite('sbreak');

    if (numtry > maxtry) then          (* if too many tries, give up *)
      begin
        sbreak := 'a';
        exit(sbreak)
      end;
    numtry := numtry + 1;

    refresh_screen(numtry,n);

    spack('B',(n mod 64),0,packet);    (* send end of file packet *)

    ch := rpack(len,num,recpkt);
    if ch = 'N' then                   (* NAK, so just stay in this state *)
        if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
            exit(sbreak)               (* is just like ACK for this packet *)
        else
          begin
            if num > 0 then
                num := (num - 1)       (* in which case, decrement num *)
            else
                num := 63;
            ch := 'Y';                 (* and indicate an ACK *)
          end; (* else *)

    if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then    (* if wrong ACK, stay in B state *)
            exit(sbreak);
        numtry := 0;
        n := n + 1;
        sbreak := 'c'                  (* else, switch state to complete *)
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sbreak := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then         (* receive failed, so stay in z state *)
      begin
      end
    else if (ch <> 'N') then           (* other error, just abort *)
        sbreak := 'a'
  end; (* sbreak *)

(* state table switcher for sending *)

  begin (* sendsw *)

    if debug then
        debugwrite(concat('Opening ',filename));

    openfile;
    if io_status <> 0 then
      begin
        writeln(chr(clear_screen));
        io_error(io_status);
        send_ok := false;
        exit(sendsw)
      end;

    write_screen('Sending');
    state := 's';
    n := 0;       (* set packet # *)
    numtry := 0;
    while true do
        if state in ['d', 'f', 'z', 's', 'b', 'c', 'a'] then
          case state of
              'd': state := sdata;
              'f': state := sfile;
              'z': state := seof;
              's': state := sinit;
              'b': state := sbreak;
              'c': begin
                     send_ok := true;
                     exit(sendsw)
                   end; (* case c *)
              'a': begin
                     send_ok := false;
                     exit(sendsw)
                   end (* case a *)
            end (* case *)
        else (* state not in legal states *)
          begin
            send_ok := false;
            exit(sendsw)
          end (* else *)
  end; (* sendsw *)